home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 / Ham Radio 2000.iso / ham2000 / bbs / diebox19 / rstat.pas < prev    next >
Pascal/Delphi Source File  |  1992-10-14  |  7KB  |  279 lines
  1. { Ausgabe eine Auslesestatistik fuer DIEBOX anhand von RLOG.BOX }
  2. { Version 0.2 - DL1MCX @ OE9XPI }
  3.  
  4. Program RStat;
  5. Uses Crt, Dos;
  6.  
  7. Const
  8.   MaxDir = 1024;
  9.   NoError = 0;
  10.   OpenError = 1;
  11.  
  12. Type
  13.   AnyStr     = String[255];
  14.   DirRec     = Record
  15.                  Board : String[8];
  16.                  count : Word;
  17.                End;
  18.  
  19.   DirPtr     = ^DirRec;
  20.   DirArr     = Array[1..MaxDir] of DirPtr;
  21.  
  22.   LessFunc = function(X, Y: DirPtr):Boolean;
  23.  
  24. Var
  25.   Con,
  26.   RFile        : Text;
  27.   Pfad,
  28.   LogBegin,
  29.   LogEnd       : AnyStr;
  30.   returncode   : byte;
  31.   Dir          : DirArr;
  32.   Count,RCount : Word;
  33.   Less         : LessFunc;
  34.  
  35. {-------------------------------------------------------------------------
  36.  ConstStr  fuellt einen String auf die Gesamtlaenge L mit Zeichen ch auf;
  37.           Fuer Posi wird "r" oder "l" erwartet (rechts- oder linksbuendig)
  38. --------------------------------------------------------------------------}
  39. FUNCTION ConstStr (Zeile:String; L:Integer; ch, Posi:Char) : String;
  40. Var B_Str : String;
  41. Laenge    : Byte;
  42. BEGIN
  43.   Laenge := L - length(Zeile);
  44.   IF (L < 0 ) THEN L := 0;
  45.   IF (L > 255) THEN L := 255;
  46.   fillchar(B_Str,Laenge+2,ch);
  47.   B_Str[0] := Chr(Laenge);
  48.  
  49.   If Posi = 'l'
  50.     then ConstStr  := Zeile + B_Str;
  51.   IF Posi = 'r'
  52.     then ConstStr  := B_Str + Zeile;
  53. END;
  54.  
  55. {------------------------------------------------------------------------------
  56.  isCall prüft, ob RUBRIK ein Call oder 'ne Rubrik ist
  57. +-----------------------------------------------------------------------------}
  58. FUNCTION isCall (Rubrik : String ): Boolean;
  59. const
  60.   digit = ['0'..'9'];
  61.  
  62. var
  63.   i      :  shortint;
  64.   ok     :  boolean;
  65.   count  :  shortint;
  66.   suffix :  shortint;
  67.  
  68. begin
  69.  
  70.   ok     := false;
  71.   suffix := 0;
  72.   count  := length (Rubrik);
  73.   if count in [2..7]
  74.   then
  75.  
  76.     for i:=1 to 3 do
  77.     begin
  78.       if    ( Rubrik [i] in digit )
  79.         and ( i in [2,3] )
  80.       then ok := true
  81.     end;
  82.  
  83.     if ok then
  84.       if ( Rubrik [1] in digit ) and
  85.          ( Rubrik [2] in digit )
  86.        then ok := false;       (* keine Calls mit 2 führenden Ziffern *)
  87.  
  88.     if ok then
  89.     for i:=count downto 1 do
  90.        if     not ( Rubrik [i] in digit )
  91.       then inc (suffix);
  92.  
  93.   if ok and ( suffix < 5 ) then
  94.     if not ( Rubrik [count] in digit )  then
  95.       ok := true
  96.     else ok := false;
  97.  
  98.   isCall := ok;
  99. end;
  100.  
  101. {-----------------------------------------------------------------------
  102.  Sortierfunktionen
  103.  -----------------------------------------------------------------------}
  104. {$F+}
  105.  
  106. (* numerisch sortieren *)
  107. function MoreCount(X, Y : DirPtr): Boolean;
  108. begin
  109.   MoreCount := X^.Count > Y^.Count;
  110. end;
  111.  
  112. {$F-}
  113.  
  114. {----------------------------------------------------------------------
  115.  QuickSort  Sortieralgorithmus
  116.  ----------------------------------------------------------------------}
  117. procedure QuickSort(L, R: Integer);
  118. var
  119.   I, J: Integer;
  120.   X, Y: DirPtr;
  121.   Z   : DirPtr;
  122. begin
  123.   I := L;
  124.   J := R;
  125.   X := Dir[(L + R) div 2];
  126.   repeat
  127.     while Less(Dir[I], X) do Inc(I);
  128.     while Less(X, Dir[J]) do Dec(J);
  129.     if I <= J then
  130.     begin
  131.       Y := Dir[I];
  132.       Dir[I] := Dir[J];
  133.       Dir[J] := Y;
  134.       Inc(I);
  135.       Dec(J);
  136.     end;
  137.   until I > J;
  138.   if L < J then QuickSort(L, J);
  139.   if I < R then QuickSort(I, R);
  140. end;
  141.  
  142. {------------------------------------------------------------------------------
  143.  Take_Pfad   holt den Pfad
  144. +-----------------------------------------------------------------------------}
  145. PROCEDURE Take_Pfad(Var Pfad : Anystr);
  146. Var
  147.      Zeile     : Anystr;
  148. BEGIN
  149.   Pfad := GetEnv('MB_DIR') + 'PROTO\';
  150. END;
  151.  
  152. {------------------------
  153.  OpenRFile oeffen LogFile
  154.  ------------------------}
  155. Function OpenRFile : Byte;
  156. Begin
  157.   ASSIGN(RFile,pfad + 'RLOG.BOX');
  158.   {$I-} RESET(RFile); {$I+}
  159.   IF IOResult <> 0
  160.     then OpenRFile := OpenError
  161.   else
  162.     OpenRFile := noerror;
  163. End;
  164.  
  165. {-------------------------------------
  166.  ReadRFile liest Daten aus Logfile ein
  167.  -------------------------------------}
  168. Procedure ReadRFile;
  169. Var
  170.   i,z   : Word;
  171.   Zeile : AnyStr;
  172.   Board : String[12];
  173.   found : boolean;
  174.  
  175. Begin
  176.   i := 0;
  177.   While (not EOF(RFile) and (i < MaxDir)) do
  178.     begin
  179.       Readln(RFile,Zeile);
  180.     
  181. (*
  182.  1 22.06.92 00:18 DL1MCX: IBM         1 ZBPKNL
  183. *)
  184.       if i = 0 then LogBegin := Copy(Zeile,4,14);
  185.       Board := Copy(Zeile,27,9);
  186.       Board := Copy(Board,1,Pos(' ',Board)-1);
  187.       If (not(iscall(Board)) and (length(Board) > 1)) then
  188.         begin
  189.           inc(RCount);
  190.           found := false;
  191.           z := 1;
  192.           While ((z <= i) and (not found)) do
  193.             begin
  194.               If Dir[z]^.Board = Board then
  195.                 begin
  196.                   found := true;
  197.                   inc(Dir[z]^.count);
  198.                 end;
  199.               inc(z);
  200.             end;
  201.           If (not found) then
  202.             begin
  203.               inc(i);
  204.               If (MaxAvail < SizeOf(DirRec))
  205.               then
  206.                 begin
  207.                   Writeln(Con,#13#10'Nicht genügend Speicher, Programm abgebrochen');
  208.                   close(RFile);
  209.                   close(con);
  210.                   halt;
  211.                 end
  212.               else
  213.                 begin
  214.                   New(Dir[i]);
  215.                   Dir[i]^.Board := Board;
  216.                   Dir[i]^.count := 1;
  217.                 end;
  218.             end;
  219.           end;
  220.     End;
  221.     LogEnd := Copy(Zeile,4,14);
  222.     Count := i;
  223.     if (i = MaxDir) then
  224.       writeln(con,#13#10'Speichermangel - Daten unvollständig !');
  225.   Close(RFile);
  226. End;
  227.  
  228. {------------------------
  229.  WriteStat gibt Liste aus
  230.  ------------------------}
  231. Procedure WriteStat;
  232. Var
  233.   i     : Word;
  234.   c     : Byte;
  235.   match : Word;
  236.   Board : String[12];
  237.   CountStr: String[6];
  238.   Outline : AnyStr;
  239.  
  240. Begin
  241.   c := 1;
  242.   For i := 1 to Count do
  243.     begin
  244.       Board := Dir[i]^.Board;
  245.       Str(Dir[i]^.Count,CountStr);
  246.       Outline := ConstStr(Board,(13-length(CountStr)),'.','l') + CountStr + '  ';
  247.       Write(Con,OutLine);
  248.       inc(c);
  249.       if c = 6 then
  250.        begin
  251.          Writeln(Con);
  252.          c := 1;
  253.        end;
  254.     end;
  255.   Writeln(Con);
  256.   Writeln(Con,'Gesamt: ',RCount);
  257. End;
  258.  
  259. Begin
  260.   DirectVideo := False;
  261.   RCount := 0;
  262.   Less := MoreCount;
  263.   ASSIGN(Con,'');
  264.   REWRITE(Con);
  265.   Write(Con,#13#10'RStat v0.2 (DL1MCX)');
  266.   Take_Pfad(Pfad);
  267.   Returncode := OpenRFile;
  268.   if Returncode = noerror then
  269.     begin
  270.       ReadRFile;
  271.       Writeln(Con,' - Statistik vom ',Logbegin,' bis ',LogEnd,#13#10);
  272.       quicksort (1,Count);
  273.       WriteStat;
  274.     end;
  275.   Writeln(Con);
  276.   Close(Con);
  277. End.
  278.  
  279.